home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Cartiers-Contribs / Modules / extended-apropos / subviews.lisp < prev    next >
Encoding:
Text File  |  1992-09-08  |  36.1 KB  |  1,456 lines  |  [TEXT/CCL2]
  1. ;;; -*- package: CC -*-
  2. ;;;
  3. ;;;; Extended apropos's subviews
  4. ;;;
  5.  
  6.  
  7. (in-package "CC")
  8.  
  9.  
  10. ;;;
  11. ;;;; Help button
  12. ;;;
  13.  
  14.  
  15. (defvar *help-buffer*
  16.   (let ((buffer (make-buffer)))
  17.     (buffer-insert-file buffer "cc:modules;extended-apropos;HELP")
  18.     (%buffer-set-read-only buffer t)
  19.     buffer))
  20.  
  21. (defvar *help-window*
  22.   nil)
  23.  
  24.  
  25. (defclass help-button (button-dialog-item)
  26.     ()
  27.   (:default-initargs
  28.     :dialog-item-text "?"))
  29.  
  30.  
  31. (defmethod help-string ((self help-button))
  32.   (format nil "Brings up a window containing documentation on how to use ~
  33.                this dialog, including a step by step tutorial of some of ~
  34.                its features."))
  35.  
  36.  
  37. (defmethod dialog-item-action ((self help-button))
  38.   (cond ((or (null *help-window*)
  39.              (null (wptr *help-window*)))
  40.          (make-instance 'fred-window
  41.            :window-title "Extended Apropos Help"
  42.            :buffer *help-buffer*
  43.            :scratch-p t
  44.            :save-buffer-p t))
  45.         (t (set-window-layer *help-window* 0)
  46.            (window-show *help-window*))))
  47.  
  48.  
  49. ;;;
  50. ;;;; Apropos title
  51. ;;;
  52.  
  53.  
  54. (defclass apropos-title (static-text-dialog-item)
  55.     ()
  56.   (:default-initargs
  57.     :dialog-item-text "Search for all symbols whose:"))
  58.  
  59.  
  60. (defmethod help-string ((self apropos-title))
  61.   (help-string *apropos*))
  62.  
  63.  
  64. ;;;
  65. ;;;; Name subview
  66. ;;;
  67.  
  68.  
  69. (defclass name-subview (apropos-contour-view)
  70.     ())
  71.  
  72.  
  73. (defmethod help-string ((self name-subview))
  74.   (help-string *apropos*))
  75.  
  76.  
  77. (defmethod install-view-in-window ((self name-subview) window)
  78.   (declare (ignore window))
  79.   (add-subviews self
  80.     (make-instance 'name-title :view-position #@( 25 1))
  81.     (make-instance 'name-menu  :view-position #@(175 0))
  82.     (make-instance 'name-text  :view-position #@(328 3))))
  83.  
  84.  
  85. ;;;
  86. ;;;; Name title
  87. ;;;
  88.  
  89.  
  90. (defclass name-title (static-text-dialog-item)
  91.     ()
  92.   (:default-initargs
  93.     :dialog-item-text "name"))
  94.  
  95.  
  96. (defmethod help-string ((self name-title))
  97.   (help-string *apropos*))
  98.  
  99.  
  100. ;;;
  101. ;;;; Name menu
  102. ;;;
  103.  
  104.  
  105. (defclass name-menu (selection-pop-up)
  106.     ()
  107.   (:default-initargs
  108.     :list '((:contains    "contains")
  109.             (:starts-with "starts with")
  110.             (:ends-in     "ends in"))
  111.     :view-nick-name 'name-menu
  112.     :view-size #@(140 20)))
  113.  
  114.  
  115. (defmethod help-string ((self name-menu))
  116.   "Use this menu to describe symbols you want to search for.")
  117.  
  118.  
  119. (defun name-filter (&optional from-apropos-list)
  120.   (let* ((test (selected-item (apropos-view 'name-menu)))
  121.          (text (dialog-item-text (apropos-view 'name-text)))
  122.          (tlen (length text)))
  123.     (function
  124.       (lambda (symbol)
  125.         (let* ((name (symbol-name symbol))
  126.                (slen (length name)))
  127.           (and (or from-apropos-list (<= tlen slen))
  128.                (case test
  129.                  (:contains (or from-apropos-list
  130.                                 (search text name :test (function char-equal))))
  131.                  (:starts-with (string-equal text name :end2 tlen))
  132.                  (:ends-in (string-equal text name :start2 (- slen tlen))))))))))
  133.  
  134.  
  135. ;;;
  136. ;;;; Name text
  137. ;;;
  138.  
  139.  
  140. (defclass name-text (editable-text-dialog-item)
  141.     ()
  142.   (:default-initargs
  143.     :view-nick-name 'name-text
  144.     :view-size #@(133 14)))
  145.  
  146.  
  147. (defmethod help-string ((self name-text))
  148.   "The substring that will be searched for.")
  149.  
  150.  
  151. ;;;
  152. ;;;; Criterion subview
  153. ;;;
  154.  
  155.  
  156. (defclass criterion-subview (apropos-contour-view)
  157.     ((arg1)
  158.      (arg2))
  159.   (:default-initargs
  160.     :view-nick-name 'criterion-subview))
  161.  
  162.  
  163. (defmethod help-string ((self criterion-subview))
  164.   (help-string *apropos*))
  165.  
  166.  
  167. (defun criterion-action ()
  168.   (let ((view (apropos-view 'criterion-subview))
  169.         (menu (selected-item (apropos-view 'criterion-menu))))
  170.     (with-slots (arg1 arg2) view
  171.       (when arg1 (remove-subviews view arg1))
  172.       (when arg2 (remove-subviews view arg2))
  173.       (case menu
  174.         (:represents
  175.           (add-subviews view
  176.             (setf arg1 (make-instance 'represents-menu :view-position #@(175 0)))
  177.             (setf arg2 (make-instance 'value-menu      :view-position #@(325 0)))))
  178.         (:documentation
  179.           (add-subviews view
  180.             (setf arg1 (make-instance 'documentation-menu           :view-position #@(175 0)))
  181.             (setf arg2 (make-instance 'documentation-available-menu :view-position #@(325 0)))))
  182.         (:definition
  183.           (add-subviews view
  184.             (setf arg1 (make-instance 'definition-prompt :view-position #@(175 1)))
  185.             (setf arg2 (make-instance 'definition-menu   :view-position #@(325 0)))))
  186.         (:property-list
  187.           (add-subviews view
  188.             (setf arg1 (make-instance 'property-list-menu       :view-position #@(175 0)))
  189.             (setf arg2 (make-instance 'property-list-bound-menu :view-position #@(325 0)))))
  190.         (:satisfies
  191.           (add-subviews view
  192.             (setf arg1 (make-instance 'satisfies-prompt    :view-position #@(175 1)))
  193.             (setf arg2 (make-instance 'satisfies-predicate :view-position #@(328 3)))))))))
  194.  
  195.  
  196. (defmethod install-view-in-window ((self criterion-subview) window)
  197.   (declare (ignore window))
  198.   (with-slots (arg1 arg2) self
  199.     (add-subviews self
  200.       (make-instance 'criterion-check-box :view-position #@(  0 1))
  201.       (make-instance 'criterion-menu      :view-position #@( 25 0))
  202.       (setf arg1 (make-instance 'represents-menu :view-position #@(175 0)))
  203.       (setf arg2 (make-instance 'value-menu      :view-position #@(325 0))))))
  204.  
  205.  
  206. (defun criterion-filter ()
  207.   (let ((checked-p (check-box-checked-p (apropos-view 'criterion-check-box)))
  208.         (criterion (selected-item (apropos-view 'criterion-menu))))
  209.     (if (not checked-p)
  210.         (function true)
  211.       (case criterion
  212.         (:represents (represents-filter))
  213.         (:documentation (documentation-filter))
  214.         (:definition (definition-filter))
  215.         (:property-list (property-list-filter))
  216.         (:satisfies (satisfies-filter))))))
  217.  
  218.  
  219. ;;;
  220. ;;;; Criterion check box
  221. ;;;
  222.  
  223.  
  224. (defclass criterion-check-box (check-box-dialog-item)
  225.     ()
  226.   (:default-initargs
  227.     :view-nick-name 'criterion-check-box))
  228.  
  229.  
  230. (defmethod help-string ((self criterion-check-box))
  231.   "Specifies wheter or not this line is to be used in the search.")
  232.  
  233.  
  234. (defmethod dialog-item-action :after ((self criterion-check-box))
  235.   (auto-search-action))
  236.  
  237.  
  238. ;;;
  239. ;;;; Criterion menu
  240. ;;;
  241.  
  242.  
  243. (defclass criterion-menu (selection-pop-up)
  244.     ()
  245.   (:default-initargs
  246.     :list '((:represents    "name represents")
  247.             (:documentation "documentation")
  248.             (:definition    "definition")
  249.             (:property-list "property list")
  250.             nil
  251.             (:satisfies     "self satisfies"))
  252.     :menu-item-action 'criterion-action
  253.     :view-nick-name 'criterion-menu
  254.     :view-size #@(140 20)))
  255.  
  256.  
  257. (defmethod help-string ((self criterion-menu))
  258.   "Use this menu to describe symbols you want to search for.")
  259.  
  260.  
  261. ;;;
  262. ;;;; Represents menu
  263. ;;;
  264.  
  265.  
  266. (defclass represents-menu (selection-pop-up)
  267.     ()
  268.   (:default-initargs
  269.     :list '((:value       "a value type:")
  270.             (:function    "a function type:")
  271.             (:macro       "a macro type:")
  272.             nil
  273.             (:class       "a class:")
  274.             (:condition   "a condition:")
  275.             nil
  276.             (:macintosh   "a macintosh")
  277.             (:common-lisp "a common lisp"))
  278.     :menu-item-action 'represents-action
  279.     :view-nick-name 'represents-menu
  280.     :view-size #@(140 20)))
  281.  
  282.  
  283. (defmethod help-string ((self represents-menu))
  284.   "Use this menu to describe symbols you want to search for.")
  285.  
  286.  
  287. (defun represents-action ()
  288.   (let ((criterion (apropos-view 'criterion-subview))
  289.         (represents (selected-item (apropos-view 'represents-menu))))
  290.     (with-slots (arg2) criterion
  291.       (when arg2 (remove-subviews criterion arg2))
  292.       (add-subviews criterion
  293.         (setf arg2
  294.               (make-instance (case represents
  295.                                (:value       'value-menu)
  296.                                (:function    'function-menu)
  297.                                (:macro       'macro-menu)
  298.                                (:class       'class-menu)
  299.                                (:condition   'condition-menu)
  300.                                (:macintosh   'macintosh-menu)
  301.                                (:common-lisp 'common-lisp-menu))
  302.                 :view-position #@(325 0)))))))
  303.  
  304.  
  305. (defun represents-filter ()
  306.   (case (selected-item (apropos-view 'represents-menu))
  307.     (:value       (value-filter))
  308.     (:function    (function-filter))
  309.     (:macro       (macro-filter))
  310.     (:class       (class-filter))
  311.     (:condition   (condition-filter))
  312.     (:macintosh   (macintosh-filter))
  313.     (:common-lisp (common-lisp-filter))))
  314.  
  315.  
  316. ;;;
  317. ;;;; Value menu
  318. ;;;
  319.  
  320.  
  321. (defclass value-menu (selection-pop-up)
  322.     ()
  323.   (:default-initargs
  324.     :list '((:any      "any")
  325.             (:bound    "bound")
  326.             nil
  327.             (:variable "variable")
  328.             (:constant "constant"))
  329.     :view-nick-name 'value-menu
  330.     :view-size #@(140 20)))
  331.  
  332.  
  333. (defmethod help-string ((self value-menu))
  334.   "Use this menu to describe symbols you want to search for.")
  335.  
  336.  
  337. (defun value-filter ()
  338.   (let ((binding-type (selected-item (apropos-view 'value-menu))))
  339.     (function
  340.       (lambda (symbol)
  341.         (case binding-type
  342.           (:any      (proclaimed-special-p symbol))
  343.           (:bound    (boundp symbol))
  344.           (:variable (and (proclaimed-special-p symbol) (not (constantp symbol))))
  345.           (:constant (constantp symbol)))))))
  346.  
  347.  
  348. ;;;
  349. ;;;; Function menu
  350. ;;;
  351.  
  352.  
  353. (defclass function-menu (selection-pop-up)
  354.     ()
  355.   (:default-initargs
  356.     :list '((:any      "any")
  357.             nil
  358.             (:function "function")
  359.             (:generic  "generic function"))
  360.     :view-nick-name 'function-menu
  361.     :view-size #@(140 20)))
  362.  
  363.  
  364. (defmethod help-string ((self function-menu))
  365.   "Use this menu to describe symbols you want to search for.")
  366.  
  367.  
  368. (defun function-filter ()
  369.   (let ((binding-type (selected-item (apropos-view 'function-menu))))
  370.     (function
  371.       (lambda (symbol)
  372.         (case binding-type
  373.           (:any (functional-p symbol))
  374.           (:function (function-p symbol))
  375.           (:generic (generic-function-p symbol)))))))
  376.  
  377.  
  378. (defun functional-p (symbol)
  379.   (and (fboundp symbol)
  380.        (not (macro-function symbol))
  381.        (not (special-form-p symbol))))
  382.  
  383.  
  384. (defun function-p (symbol)
  385.   (and (functional-p symbol)
  386.        (not (subtypep (type-of (symbol-function symbol))
  387.                       'standard-generic-function))))
  388.  
  389.  
  390. (defun generic-function-p (symbol)
  391.   (and (functional-p symbol)
  392.        (subtypep (type-of (symbol-function symbol))
  393.                  'standard-generic-function)))
  394.  
  395.  
  396. ;;;
  397. ;;;; Macro menu
  398. ;;;
  399.  
  400.  
  401. (defclass macro-menu (selection-pop-up)
  402.     ()
  403.   (:default-initargs
  404.     :list '((:any            "any")
  405.             nil
  406.             (:macro          "macro")
  407.             (:special-form   "special form")
  408.             (:compiler-macro "compiler macro"))
  409.     :view-nick-name 'macro-menu
  410.     :view-size #@(140 20)))
  411.  
  412.  
  413. (defmethod help-string ((self macro-menu))
  414.   "Use this menu to describe symbols you want to search for.")
  415.  
  416.  
  417. (defun macro-filter ()
  418.   (let ((binding-type (selected-item (apropos-view 'macro-menu))))
  419.     (function
  420.       (lambda (symbol)
  421.         (case binding-type
  422.           (:any (or (macro-function symbol)
  423.                     (special-form-p symbol)
  424.                     (compiler-macro-function symbol)))
  425.           (:macro          (macro-function symbol))
  426.           (:special-form   (special-form-p symbol))
  427.           (:compiler-macro (compiler-macro-function symbol)))))))
  428.  
  429.  
  430. ;;;
  431. ;;;; Class menu
  432. ;;;
  433.  
  434.  
  435. (defclass class-menu (selection-pop-up)
  436.     ()
  437.   (:default-initargs
  438.     :list '((:any            "any")
  439.             nil
  440.             (standard-class  "standard-class")
  441.             (built-in-class  "built-in-class")
  442.             (structure-class "structure-class"))
  443.     :view-nick-name 'class-menu
  444.     :view-size #@(140 20)))
  445.  
  446.  
  447. (defmethod help-string ((self class-menu))
  448.   "Use this menu to describe symbols you want to search for.")
  449.  
  450.  
  451. (defun class-filter ()
  452.   (let ((class (selected-item (apropos-view 'class-menu))))
  453.     (function
  454.       (lambda (symbol)
  455.         (let ((class-of-symbol (find-class symbol nil)))
  456.           (and class-of-symbol
  457.                (or (eq class :any)
  458.                    (subtypep (type-of class-of-symbol)
  459.                              class))))))))
  460.  
  461.  
  462. ;;;
  463. ;;;; Condition menu
  464. ;;;
  465.  
  466.  
  467. (defclass condition-menu (selection-pop-up)
  468.     ()
  469.   (:default-initargs
  470.     :list '((condition         "any")
  471.             nil
  472.             (error             "error")
  473.             (warning           "warning")
  474.             (compiler-warning  "compiler-warning")
  475.             nil
  476.             (simple-condition  "simple-condition")
  477.             (serious-condition "serious-condition"))
  478.     :view-nick-name 'condition-menu
  479.     :view-size #@(140 20)))
  480.  
  481.  
  482. (defmethod help-string ((self condition-menu))
  483.   "Use this menu to describe symbols you want to search for.")
  484.  
  485.  
  486. (defun condition-filter ()
  487.   (let ((condition (selected-item (apropos-view 'condition-menu))))
  488.     (function
  489.       (lambda (symbol)
  490.         (subtypep symbol condition)))))
  491.  
  492.  
  493. ;;;
  494. ;;;; Macintosh menu
  495. ;;;
  496.  
  497.  
  498. (defclass macintosh-menu (selection-pop-up)
  499.     ()
  500.   (:default-initargs
  501.     :list '((:record  "record type")
  502.             (:mactype "mactype"))
  503.     :view-nick-name 'macintosh-menu
  504.     :view-size #@(140 20)))
  505.  
  506.  
  507. (defmethod help-string ((self macintosh-menu))
  508.   "Use this menu to describe symbols you want to search for.")
  509.  
  510.  
  511. (defun macintosh-filter ()
  512.   (let ((what (selected-item (apropos-view 'macintosh-menu))))
  513.     (function
  514.       (lambda (symbol)
  515.         (case what
  516.           (:record (record-type-p symbol))
  517.           (:mactype (mactype-p symbol)))))))
  518.  
  519.  
  520. ;;;
  521. ;;;; Common lisp menu
  522. ;;;
  523.  
  524.  
  525. (defclass common-lisp-menu (selection-pop-up)
  526.     ()
  527.   (:default-initargs
  528.     :list '((:type-specifier "type specifier")
  529.             (:declaration    "declaration"))
  530.     :view-nick-name 'common-lisp-menu
  531.     :view-size #@(140 20)))
  532.  
  533.  
  534. (defmethod help-string ((self common-lisp-menu))
  535.   "Use this menu to describe symbols you want to search for.")
  536.  
  537.  
  538. (defun common-lisp-filter ()
  539.   (let ((what (selected-item (apropos-view 'common-lisp-menu))))
  540.     (function
  541.       (lambda (symbol)
  542.         (case what
  543.           (:type-specifier (type-specifier-p symbol))
  544.           (:declaration (member symbol *nx-known-declarations*)))))))
  545.  
  546.  
  547. ;;;
  548. ;;;; Documentation menu
  549. ;;;
  550.  
  551.  
  552. (defclass documentation-menu (selection-pop-up)
  553.     ()
  554.   (:default-initargs
  555.     :list '((:is "is")
  556.             (:contains "contains"))
  557.     :menu-item-action 'documentation-action
  558.     :view-nick-name 'documentation-menu
  559.     :view-size #@(140 20)))
  560.  
  561.  
  562. (defmethod help-string ((self documentation-menu))
  563.   "Use this menu to describe symbols you want to search for.")
  564.  
  565.  
  566. (defun documentation-action ()
  567.   (let ((criterion (apropos-view 'criterion-subview))
  568.         (what (selected-item (apropos-view 'documentation-menu))))
  569.     (with-slots (arg2) criterion
  570.       (when arg2 (remove-subviews criterion arg2))
  571.       (add-subviews criterion
  572.         (setf arg2
  573.               (case what
  574.                 (:is
  575.                   (make-instance 'documentation-available-menu
  576.                     :view-position #@(325 0)))
  577.                 (:contains
  578.                   (make-instance 'documentation-text
  579.                     :view-position #@(328 3)))))))))
  580.  
  581.  
  582. (defun documentation-filter ()
  583.   (let ((what (selected-item (apropos-view 'documentation-menu))))
  584.     (case what
  585.       (:is (documentation-available-filter))
  586.       (:contains (documentation-contains-filter)))))
  587.  
  588.  
  589. ;;;
  590. ;;;; Documentation available menu
  591. ;;;
  592.  
  593.  
  594. (defclass documentation-available-menu (selection-pop-up)
  595.     ()
  596.   (:default-initargs
  597.     :list '((:available "available")
  598.             (:not-available "not available"))
  599.     :view-nick-name 'documentation-available-menu
  600.     :view-size #@(140 20)))
  601.  
  602.  
  603. (defmethod help-string ((self documentation-available-menu))
  604.   "Use this menu to describe symbols you want to search for.")
  605.  
  606.  
  607. (defun documentation-available-filter ()
  608.   (let ((what (selected-item (apropos-view 'documentation-available-menu))))
  609.     (function
  610.       (lambda (symbol)
  611.         (case what
  612.           (:available (gethash symbol *fast-help*))
  613.           (:not-available (not (gethash symbol *fast-help*))))))))
  614.  
  615.  
  616. ;;;
  617. ;;;; Documentation text
  618. ;;;
  619.  
  620.  
  621. (defclass documentation-text (editable-text-dialog-item)
  622.     ()
  623.   (:default-initargs
  624.     :view-nick-name 'documentation-text
  625.     :view-size #@(133 14)))
  626.  
  627.  
  628. (defmethod help-string ((self documentation-text))
  629.   "The documentation substring that will be searched for.")
  630.  
  631.  
  632. (defun documentation-contains-filter ()
  633.   (let ((string (dialog-item-text (apropos-view 'documentation-text))))
  634.     (function
  635.       (lambda (symbol)
  636.         (let ((doc (documentation symbol nil)))
  637.           (and doc
  638.                (search string doc :test (function char-equal))))))))
  639.  
  640.  
  641. ;;;
  642. ;;;; Definition prompt
  643. ;;;
  644.  
  645.  
  646. (defclass definition-prompt (static-text-dialog-item)
  647.     ()
  648.   (:default-initargs
  649.     :dialog-item-text "can be"))
  650.  
  651.  
  652. (defmethod help-string ((self definition-prompt))
  653.   (help-string *apropos*))
  654.  
  655.  
  656. ;;;
  657. ;;;; Definition menu
  658. ;;;
  659.  
  660.  
  661. (defclass definition-menu (selection-pop-up)
  662.     ()
  663.   (:default-initargs
  664.     :list '((:edited     "edited")
  665.             (:uncompiled "uncompiled"))
  666.     :view-nick-name 'definition-menu
  667.     :view-size #@(140 20)))
  668.  
  669.  
  670. (defmethod help-string ((self definition-menu))
  671.   "Use this menu to describe symbols you want to search for.")
  672.  
  673.  
  674. (defun definition-filter ()
  675.   (let ((test (selected-item (apropos-view 'definition-menu))))
  676.     (function
  677.       (lambda (symbol)
  678.         (case test
  679.           (:edited (edit-definition-p symbol))
  680.           (:uncompiled (uncompile-function symbol)))))))
  681.  
  682.  
  683. ;;;
  684. ;;;; Property list menu
  685. ;;;
  686.  
  687.  
  688. (defclass property-list-menu (selection-pop-up)
  689.     ()
  690.   (:default-initargs
  691.     :list '((:is       "is")
  692.             (:property "has property"))
  693.     :menu-item-action 'property-list-action
  694.     :view-nick-name 'property-list-menu
  695.     :view-size #@(140 20)))
  696.  
  697.  
  698. (defmethod help-string ((self property-list-menu))
  699.   "Use this menu to describe symbols you want to search for.")
  700.  
  701.  
  702. (defun property-list-action ()
  703.   (let ((criterion (apropos-view 'criterion-subview))
  704.         (item (selected-item (apropos-view 'property-list-menu))))
  705.     (with-slots (arg2) criterion
  706.       (when arg2 (remove-subviews criterion arg2))
  707.       (add-subviews criterion
  708.         (setq arg2
  709.               (case item
  710.                 (:is       (make-instance 'property-list-bound-menu :view-position #@(325 0)))
  711.                 (:property (make-instance 'property-list-property   :view-position #@(328 3)))))))))
  712.  
  713.  
  714. (defun property-list-filter ()
  715.   (let ((test (selected-item (apropos-view 'property-list-menu))))
  716.     (case test
  717.       (:is (property-list-bound-filter))
  718.       (:property (property-list-property-filter)))))
  719.  
  720.  
  721. ;;;
  722. ;;;; Property list bound menu
  723. ;;;
  724.  
  725.  
  726. (defclass property-list-bound-menu (selection-pop-up)
  727.     ()
  728.   (:default-initargs
  729.     :list '((:bound   "bound")
  730.             (:unbound "unbound"))
  731.     :view-nick-name 'property-list-bound-menu
  732.     :view-size #@(140 20)))
  733.  
  734.  
  735. (defmethod help-string ((self property-list-menu))
  736.   "Use this menu to describe symbols you want to search for.")
  737.  
  738.  
  739. (defun property-list-bound-filter ()
  740.   (let ((test (selected-item (apropos-view 'property-list-bound-menu))))
  741.     (function
  742.       (lambda (symbol)
  743.         (case test
  744.           (:bound (symbol-plist symbol))
  745.           (:unbound (not (symbol-plist symbol))))))))
  746.  
  747.  
  748. ;;;
  749. ;;;; Property list property
  750. ;;;
  751.  
  752.  
  753. (defclass property-list-property (editable-text-dialog-item)
  754.     ()
  755.   (:default-initargs
  756.     :view-nick-name 'property-list-property
  757.     :view-size #@(133 14)))
  758.  
  759.  
  760. (defmethod help-string ((self property-list-property))
  761.   "The property that will be searched for.")
  762.  
  763.  
  764. (defun property-list-property-filter ()
  765.   (let ((property (read-from-string (dialog-item-text (apropos-view 'property-list-property)))))
  766.     (function
  767.       (lambda (symbol)
  768.         (neq (get symbol property 'no-property-found)
  769.              'no-property-found)))))
  770.  
  771.  
  772. ;;;
  773. ;;;; Satisfies prompt
  774. ;;;
  775.  
  776.  
  777. (defclass satisfies-prompt (static-text-dialog-item)
  778.     ()
  779.   (:default-initargs
  780.     :dialog-item-text "the predicate"))
  781.  
  782.  
  783. (defmethod help-string ((self satisfies-prompt))
  784.   (help-string *apropos*))
  785.  
  786.  
  787. ;;;
  788. ;;;; Satisfies predicate
  789. ;;;
  790.  
  791.  
  792. (defclass satisfies-predicate (editable-text-dialog-item)
  793.     ()
  794.   (:default-initargs
  795.     :view-nick-name 'satisfies-predicate
  796.     :view-size #@(133 14)))
  797.  
  798.  
  799. (defmethod help-string ((self satisfies-predicate))
  800.   "Symbols found will have to satisfy this lisp predicate.")
  801.  
  802.  
  803. (defun satisfies-filter ()
  804.   (let ((predicate (read-from-string (dialog-item-text (apropos-view 'satisfies-predicate)))))
  805.     (symbol-function predicate)))
  806.  
  807.  
  808. ;;;
  809. ;;;; Package subview
  810. ;;;
  811.  
  812.  
  813. (defclass package-subview (apropos-contour-view)
  814.     ()
  815.   (:default-initargs
  816.     :view-nick-name 'package-subview))
  817.  
  818.  
  819. (defmethod help-string ((self package-subview))
  820.   (help-string *apropos*))
  821.  
  822.  
  823. (defmethod install-view-in-window ((self package-subview) window)
  824.   (declare (ignore window))
  825.   (add-subviews self
  826.     (make-instance 'package-text :view-position #@( 0 1))
  827.     (make-instance 'package-menu :view-position #@(70 0))))
  828.  
  829.  
  830. ;;;
  831. ;;;; Package text
  832. ;;;
  833.  
  834.  
  835. (defclass package-text (static-text-dialog-item)
  836.     ()
  837.   (:default-initargs
  838.     :dialog-item-text "Search in"))
  839.  
  840.  
  841. (defmethod help-string ((self package-text))
  842.   (help-string *apropos*))
  843.  
  844.  
  845. ;;;
  846. ;;;; Package menu
  847. ;;;
  848.  
  849.  
  850. (defclass package-menu (selection-pop-up)
  851.     ()
  852.   (:default-initargs
  853.     :list `((nil "all packages")
  854.             nil
  855.             ,@(all-packages))
  856.     :menu-item-action 'package-action
  857.     :view-nick-name 'package-menu
  858.     :view-size #@(175 20)))
  859.  
  860.  
  861. (defmethod initialize-instance :after ((menu package-menu) &key)
  862.   (setf (pop-up-menu-default-item menu)
  863.         (+ (position *default-package* (slot-value menu 'list)
  864.                      :key (function car))
  865.              1)))
  866.  
  867.  
  868. (defmethod help-string ((self package-menu))
  869.   (format nil "Use this menu to specify which package(s) to search into.~%~%~
  870.                This menu is not automatically updated when new packages are ~
  871.                either created or deleted. Closing and reopening the apropos ~
  872.                dialog will update the list of packages."))
  873.  
  874.  
  875. (defun package-action ()
  876.   (setf *default-package*
  877.         (selected-item (apropos-view 'package-menu))))
  878.  
  879.  
  880. (defun package-and-heritage-filter ()
  881.   (let ((package  (selected-item (apropos-view 'package-menu)))
  882.         (heritage (selected-item (apropos-view 'heritage-menu))))
  883.     (function
  884.       (lambda (symbol)
  885.         (let ((package (or package (symbol-package symbol))))
  886.           (or (eq heritage :all)
  887.               (multiple-value-bind (ignore symbol-type) 
  888.                                    (find-symbol (symbol-name symbol)
  889.                                                 package)
  890.                 (declare (ignore ignore))
  891.                 (eq symbol-type heritage))))))))
  892.  
  893.  
  894. (defun reinstall-package-menu ()
  895.   (let ((view (apropos-view 'package-subview)))
  896.     (remove-subviews view (apropos-view 'package-menu))
  897.     (add-subviews    view (make-instance 'package-menu
  898.                             :view-position #@(70 0)))))
  899.  
  900.  
  901. (defun all-packages ()
  902.   (sort
  903.     (mapcar (function
  904.               (lambda (package)
  905.                 (list package
  906.                       (concatenate 'string
  907.                                    "pkg "
  908.                                    (string-downcase (package-name package))))))
  909.             (list-all-packages))
  910.     (function string-lessp)
  911.     :key (function second)))
  912.  
  913.  
  914. ;;;
  915. ;;;; Heritage subview
  916. ;;;
  917.  
  918.  
  919. (defclass heritage-subview (apropos-contour-view)
  920.     ())
  921.  
  922.  
  923. (defmethod help-string ((self heritage-subview))
  924.   (help-string *apropos*))
  925.  
  926.  
  927. (defmethod install-view-in-window ((self heritage-subview) window)
  928.   (declare (ignore window))
  929.   (add-subviews self
  930.     (make-instance 'heritage-text :view-position #@( 0 1))
  931.     (make-instance 'heritage-menu :view-position #@(70 0))))
  932.  
  933.  
  934. ;;;
  935. ;;;; Heritage text
  936. ;;;
  937.  
  938.  
  939. (defclass heritage-text (static-text-dialog-item)
  940.     ()
  941.   (:default-initargs
  942.     :dialog-item-text "Show"))
  943.  
  944.  
  945. (defmethod help-string ((self heritage-text))
  946.   (help-string *apropos*))
  947.  
  948.  
  949. ;;;
  950. ;;;; Heritage menu
  951. ;;;
  952.  
  953.  
  954. (defclass heritage-menu (selection-pop-up)
  955.     ()
  956.   (:default-initargs
  957.     :list '((:all       "all symbols")
  958.             nil
  959.             (:external  "only external symbols")
  960.             (:internal  "only internal symbols")
  961.             (:inherited "only inherited symbols"))
  962.     :view-nick-name 'heritage-menu
  963.     :view-size #@(175 20)))
  964.  
  965.  
  966. (defmethod help-string ((self heritage-menu))
  967.   "Only those kind of symbols will be showed.")
  968.  
  969.  
  970. ;;;
  971. ;;;; Search subview
  972. ;;;
  973.  
  974.  
  975. (defclass search-subview (apropos-contour-view)
  976.     ())
  977.  
  978.  
  979. (defmethod help-string ((self search-subview))
  980.   (help-string *apropos*))
  981.  
  982.  
  983. (defmethod install-view-in-window ((self search-subview) window)
  984.   (declare (ignore window))
  985.   (add-subviews self
  986.     (make-instance 'refine-button  :view-position #@(  4  4))
  987.     (make-instance 'augment-button :view-position #@( 64  4))
  988.     (make-instance 'remove-button  :view-position #@(140  4))
  989.     (make-instance 'anchor-button  :view-position #@(  4 32))
  990.     (make-instance 'global-button  :view-position #@( 73 32))
  991.     (make-instance 'search-button  :view-position #@(141 32))))
  992.  
  993.  
  994. ;;;
  995. ;;;; Refine button
  996. ;;;
  997.  
  998.  
  999. (defclass refine-button (button-dialog-item)
  1000.     ()
  1001.   (:default-initargs
  1002.     :dialog-item-text "Refine"
  1003.     :dialog-item-action
  1004.     (function
  1005.       (lambda (self)
  1006.         (declare (ignore self))
  1007.         (eval-enqueue '(refine-action))))))
  1008.  
  1009.  
  1010. (defmethod help-string ((self refine-button))
  1011.   (format nil "Searches through the already found symbols ~
  1012.                for the ones that match the current search criteria."))
  1013.  
  1014.  
  1015. (defun refine-action ()
  1016.   (let ((*working* t))
  1017.     (new-symbols (apropos-filter (found-symbols) (global-filter)))
  1018.     (able-action-buttons)))
  1019.  
  1020.  
  1021. ;;;
  1022. ;;;; Augment button
  1023. ;;;
  1024.  
  1025.  
  1026. (defclass augment-button (button-dialog-item)
  1027.     ()
  1028.   (:default-initargs
  1029.     :dialog-item-text "Augment"
  1030.     :dialog-item-action
  1031.     (function
  1032.       (lambda (self)
  1033.         (declare (ignore self))
  1034.         (eval-enqueue '(augment-action))))))
  1035.  
  1036.  
  1037. (defmethod help-string ((self augment-button))
  1038.   (format nil "Finds all symbols in the current search domain ~
  1039.                that match the current search criteria and adds them to the ~
  1040.                ones already found."))
  1041.  
  1042.  
  1043. (defun augment-action ()
  1044.   (let ((*working* t))
  1045.     (new-symbols (union (found-symbols) (search-domain)))
  1046.     (able-action-buttons)))
  1047.  
  1048.  
  1049. ;;;
  1050. ;;;; Remove button
  1051. ;;;
  1052.  
  1053.  
  1054. (defclass remove-button (button-dialog-item)
  1055.     ()
  1056.   (:default-initargs
  1057.     :dialog-item-text "Remove"
  1058.     :dialog-item-action
  1059.     (function
  1060.       (lambda (self)
  1061.         (declare (ignore self))
  1062.         (eval-enqueue '(remove-action))))))
  1063.  
  1064.  
  1065. (defmethod help-string ((self remove-button))
  1066.   (format nil "Searches through the already found symbols ~
  1067.                for the ones that do not match the current search criteria."))
  1068.  
  1069.  
  1070. (defun remove-action ()
  1071.   (let ((*working* t))
  1072.     (new-symbols (apropos-filter (found-symbols) (inverse (global-filter))))
  1073.     (able-action-buttons)))
  1074.  
  1075.  
  1076. ;;;
  1077. ;;;; Anchor button
  1078. ;;;
  1079.  
  1080.  
  1081. (defclass anchor-button (button-dialog-item)
  1082.     ()
  1083.   (:default-initargs
  1084.     :dialog-item-text "Anchor"))
  1085.  
  1086.  
  1087. (defmethod help-string ((self anchor-button))
  1088.   "Anchors the last found symbols as the domain for later searches.")
  1089.  
  1090.  
  1091. (defmethod dialog-item-action ((self anchor-button))
  1092.   (setf *search-domain* (found-symbols))
  1093.   (dialog-item-enable (apropos-view 'global-button)))
  1094.  
  1095.  
  1096. ;;;
  1097. ;;;; Global button
  1098. ;;;
  1099.  
  1100.  
  1101. (defclass global-button (button-dialog-item)
  1102.     ()
  1103.   (:default-initargs
  1104.     :view-nick-name 'global-button
  1105.     :dialog-item-text "Global"
  1106.     :dialog-item-enabled-p nil))
  1107.  
  1108.  
  1109. (defmethod help-string ((self global-button))
  1110.   (format nil "Restores the search domain to all lisp symbols.~@[~%~%~A~]"
  1111.           (unless (dialog-item-enabled-p self)
  1112.             "Disabled because the search domain is already global.")))
  1113.  
  1114.  
  1115. (defmethod dialog-item-action ((self global-button))
  1116.   (setf *search-domain* :global)
  1117.   (dialog-item-disable self))
  1118.  
  1119.  
  1120. ;;;
  1121. ;;;; Search button
  1122. ;;;
  1123.  
  1124.  
  1125. (defclass search-button (button-dialog-item)
  1126.     ()
  1127.   (:default-initargs
  1128.     :dialog-item-text "Search"
  1129.     :default-button t
  1130.     :dialog-item-action
  1131.     (function
  1132.       (lambda (self)
  1133.         (declare (ignore self))
  1134.         (eval-enqueue '(search-action))))))
  1135.  
  1136.  
  1137. (defmethod help-string ((self search-button))
  1138.   (format nil "Finds all symbols in the current search domain ~
  1139.                that match the current search criteria.~%~%~:[~
  1140.                The current search domain is the global domain consisting ~
  1141.                of all lisp symbols.~;~
  1142.                The current search domain is not global and consists ~
  1143.                of ~A symbol~:P.~]"
  1144.           (neq *search-domain* :global)
  1145.           (length (table-sequence (apropos-view 'symbols-table)))))
  1146.  
  1147.  
  1148. (defun search-action ()
  1149.   (let ((*working* t))
  1150.     (new-symbols (search-domain))
  1151.     (able-action-buttons)))
  1152.  
  1153.  
  1154. (defun auto-search-action ()
  1155.   (let ((auto *auto-search*)
  1156.         (option (option-key-p)))
  1157.     (when (and (not (and auto option))
  1158.                (or auto option))
  1159.       (search-action))))
  1160.  
  1161.  
  1162. (defun global-filter (&optional from-apropos-list)
  1163.   (let ((name-filter (name-filter from-apropos-list))
  1164.         (criterion-filter (criterion-filter))
  1165.         (package-and-heritage-filter (package-and-heritage-filter)))
  1166.     (function
  1167.       (lambda (symbol)
  1168.         (and (funcall name-filter symbol)
  1169.              (funcall package-and-heritage-filter symbol)
  1170.              (funcall criterion-filter symbol))))))
  1171.  
  1172.  
  1173. (defun apropos-filter (symbols filter)
  1174.   (let ((value 0)
  1175.         (length (length symbols))
  1176.         (thermo (apropos-view 'search-thermometer)))
  1177.     (setf (thermometer-max-value thermo) length)
  1178.     (unwind-protect
  1179.         (iter (for symbol in symbols)
  1180.               (incf value)
  1181.               (when (= (mod value *update-frequency*) 0)
  1182.                 (setf (thermometer-value thermo) value))
  1183.               (when (funcall filter symbol)
  1184.                 (collect symbol)))
  1185.       ;; to force complete filling up
  1186.       (setf (thermometer-value thermo) length)
  1187.       (event-dispatch)
  1188.       (setf (thermometer-value thermo) 0)
  1189.       (unless (and *foreground*
  1190.                    (eq *apropos* (front-window)))
  1191.         (ed-beep)))))
  1192.  
  1193.  
  1194. (defun search-domain ()
  1195.   (cond ((eq *search-domain* :global)
  1196.          (apropos-filter (apropos-list ;; the string-upcase is not necessary in MCL 2.0 final
  1197.                                        (string-upcase (dialog-item-text (apropos-view 'name-text)))
  1198.                                        (selected-item (apropos-view 'package-menu)))
  1199.                          (global-filter t)))
  1200.         (t
  1201.          (apropos-filter *search-domain*
  1202.                          (global-filter)))))
  1203.  
  1204.  
  1205. ;;;
  1206. ;;;; Search thermometer
  1207. ;;;
  1208.  
  1209.  
  1210. (defclass search-thermometer (thermometer)
  1211.     ()
  1212.   (:default-initargs
  1213.     :direction :vertical
  1214.     :pattern *gray-pattern*
  1215.     :view-nick-name 'search-thermometer
  1216.     :view-size #@(10 72)))
  1217.  
  1218.  
  1219. (defmethod help-string ((self search-thermometer))
  1220.   "Indicates progress in the search.")
  1221.  
  1222.  
  1223. ;;;
  1224. ;;;; Action subview
  1225. ;;;
  1226.  
  1227.  
  1228. (defclass action-subview (apropos-contour-view)
  1229.     ())
  1230.  
  1231.  
  1232. (defmethod help-string ((self action-subview))
  1233.   (help-string *apropos*))
  1234.  
  1235.  
  1236. (defmethod install-view-in-window ((self action-subview) window)
  1237.   (declare (ignore window))
  1238.   (add-subviews self
  1239.     (make-instance 'inspect-button       :view-position #@(  3  5))
  1240.     (make-instance 'documentation-button :view-position #@(  3 33))
  1241.     (make-instance 'definition-button    :view-position #@(  3 61))
  1242.     (make-instance 'show-check-box       :view-position #@(  1 89))
  1243.     (make-instance 'show-text            :view-position #@( 19 89))
  1244.     (make-instance 'show-menu            :view-position #@( 60 88))))
  1245.  
  1246.  
  1247. (defun dialog-item-able (dialog-item boolean)
  1248.   (if boolean
  1249.       (dialog-item-enable dialog-item)
  1250.     (dialog-item-disable dialog-item)))
  1251.  
  1252.  
  1253. (defun able-action-buttons ()
  1254.   (let ((symbol (selected-symbol)))
  1255.     (dialog-item-able (apropos-view 'inspect-button) symbol)
  1256.     (dialog-item-able (apropos-view 'documentation-button)
  1257.                       (and symbol (documentation symbol nil)))
  1258.     (dialog-item-able (apropos-view 'definition-button)
  1259.                       (and symbol (edit-definition-p symbol)))))
  1260.  
  1261.  
  1262. ;;;
  1263. ;;;; Inspect button
  1264. ;;;
  1265.  
  1266.  
  1267. (defclass inspect-button (button-dialog-item)
  1268.     ()
  1269.   (:default-initargs
  1270.     :view-nick-name 'inspect-button
  1271.     :dialog-item-text "Inspect"
  1272.     :dialog-item-enabled-p nil))
  1273.  
  1274.  
  1275. (defmethod help-string ((self inspect-button))
  1276.   (format nil "Inspects the selected symbol.~@[~%~%~A~]"
  1277.           (unless (dialog-item-enabled-p self)
  1278.             "Disabled because no symbol is selected.")))
  1279.  
  1280.  
  1281. (defmethod dialog-item-action ((self inspect-button))
  1282.   (inspect (selected-symbol)))
  1283.  
  1284.  
  1285. ;;;
  1286. ;;;; Documentation button
  1287. ;;;
  1288.  
  1289.  
  1290. (defclass documentation-button (button-dialog-item)
  1291.     ()
  1292.   (:default-initargs
  1293.     :view-nick-name 'documentation-button
  1294.     :dialog-item-text "Documentation"
  1295.     :dialog-item-enabled-p nil))
  1296.  
  1297.  
  1298. (defmethod help-string ((self documentation-button))
  1299.   (format nil "Shows documentation for the selected symbol.~@[~%~%~A~]"
  1300.           (unless (dialog-item-enabled-p self)
  1301.             "Disabled because no symbol is selected.")))
  1302.  
  1303.  
  1304. (defmethod dialog-item-action ((self documentation-button))
  1305.   (show-documentation (selected-symbol)))
  1306.  
  1307.  
  1308. ;;;
  1309. ;;;; Definition button
  1310. ;;;
  1311.  
  1312.  
  1313. (defclass definition-button (button-dialog-item)
  1314.     ()
  1315.   (:default-initargs
  1316.     :view-nick-name 'definition-button
  1317.     :dialog-item-text "Definition"
  1318.     :dialog-item-enabled-p nil))
  1319.  
  1320.  
  1321. (defmethod help-string ((self definition-button))
  1322.   (format nil "Edits the definition of the selected symbol.~@[~%~%~A~]"
  1323.           (unless (dialog-item-enabled-p self)
  1324.             "Disabled because no symbol is selected.")))
  1325.  
  1326.  
  1327. (defmethod dialog-item-action ((self definition-button))
  1328.   (edit-definition (selected-symbol)))
  1329.  
  1330.  
  1331. ;;;
  1332. ;;;; Show check box
  1333. ;;;
  1334.  
  1335.  
  1336. (defclass show-check-box (check-box-dialog-item)
  1337.     ()
  1338.   (:default-initargs
  1339.     :view-nick-name 'show-check-box))
  1340.  
  1341.  
  1342. (defmethod help-string ((self show-check-box))
  1343.   "Specifies wheter or not the following item is to be showed next to each symbol.")
  1344.  
  1345.  
  1346. (defmethod dialog-item-action ((self show-check-box))
  1347.   (call-next-method)
  1348.   (setf *show-p* (check-box-checked-p self))
  1349.   (invalidate-view (apropos-view 'symbols-table)))
  1350.  
  1351.  
  1352. ;;;
  1353. ;;;; Show text
  1354. ;;;
  1355.  
  1356.  
  1357. (defclass show-text (static-text-dialog-item)
  1358.     ()
  1359.   (:default-initargs
  1360.     :dialog-item-text "Show"))
  1361.  
  1362.  
  1363. (defmethod help-string ((self show-text))
  1364.   (help-string *apropos*))
  1365.  
  1366.  
  1367. ;;;
  1368. ;;;; Show menu
  1369. ;;;
  1370.  
  1371.  
  1372. (defclass show-menu (selection-pop-up)
  1373.     ()
  1374.   (:default-initargs
  1375.     :list '((:value   "value")
  1376.             (:plist   "plist")
  1377.             (:package "package"))
  1378.     :menu-item-action 'show-action
  1379.     :view-nick-name 'show-menu
  1380.     :view-size #@(80 20)))
  1381.  
  1382.  
  1383. (defmethod help-string ((self show-menu))
  1384.   "The selected item will be showed for each symbol that possesses that attribute.")
  1385.  
  1386.  
  1387. (defun show-action ()
  1388.   (setf *show-what* (selected-item (apropos-view 'show-menu)))
  1389.   (invalidate-view (apropos-view 'symbols-table)))
  1390.  
  1391.  
  1392. ;;;
  1393. ;;;; Symbols table
  1394. ;;;
  1395.  
  1396.  
  1397. (defclass symbols-table (sequence-dialog-item)
  1398.     ()
  1399.   (:default-initargs
  1400.     :view-nick-name 'symbols-table
  1401.     :view-position #@(0 4)
  1402.     :view-font '("Monaco" 9 :plain)
  1403.     :cell-size (make-point (- *apropos-symbols-width* 15) 11)
  1404.     :selection-type :single
  1405.     :table-hscrollp nil
  1406.     :table-vscrollp t
  1407.     :table-sequence nil
  1408.     :table-print-function 'print-apropos-symbol))
  1409.  
  1410.  
  1411. (defmethod help-string ((self symbols-table))
  1412.   (format nil "This is the list of all symbols matching the last search.~%~%~
  1413.                The list consists of ~A symbol~:P."
  1414.           (length (table-sequence (apropos-view 'symbols-table)))))
  1415.  
  1416.  
  1417. (defmethod dialog-item-action ((self symbols-table))
  1418.   (able-action-buttons)
  1419.   (let ((modifiers (compatible-modifiers)))
  1420.     (cond
  1421.       ((or
  1422.        (double-click-p)
  1423.        (equal modifiers '(nil t nil))) (inspect (selected-symbol)))
  1424.       ((equal modifiers '(nil nil t))  (show-documentation (selected-symbol)))
  1425.       ((equal modifiers '(nil t t))    (edit-definition (selected-symbol))))))
  1426.  
  1427.  
  1428. (defun print-apropos-symbol (symbol stream)
  1429.   (format stream "~S" symbol)
  1430.   (when *show-p*
  1431.     (case *show-what*
  1432.       (:value (when (boundp symbol) (format stream ", ~S" (symbol-value symbol))))
  1433.       (:plist (when (symbol-plist symbol) (format stream ", ~S" (symbol-plist symbol))))
  1434.       (:package (format stream ", ~S" (symbol-package symbol))))))
  1435.  
  1436.  
  1437. (defun new-symbols (list)
  1438.   (let ((table (apropos-view 'symbols-table)))
  1439.     (set-table-sequence table list)
  1440.     (dolist (cell (selected-cells table))
  1441.       (cell-deselect table cell))
  1442.     (scroll-to-cell table 0 0)
  1443.     (invalidate-view table)))
  1444.  
  1445.  
  1446. (defun found-symbols ()
  1447.   (table-sequence
  1448.     (apropos-view 'symbols-table)))
  1449.  
  1450.  
  1451. (defun selected-symbol ()
  1452.   (let ((table (apropos-view 'symbols-table)))
  1453.     (let ((cells (selected-cells table)))
  1454.       (when cells
  1455.         (cell-contents table (first cells))))))
  1456.